home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / WCTUNITS / XCRT.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-30  |  17KB  |  589 lines
  1. unit xcrt;
  2.  
  3. { Written by William C. Thompson (wct@po.cwru.edu) - 1991
  4.   Parts of this unit were taken from HTScreen, written by
  5.   Harold Thunem. }
  6.  
  7. { If anyone has an idea for a procedure, please E-mail and I
  8.   will consider including it in my unit.  It should be something
  9.   that you do often. }
  10.  
  11. (* Features to be added:
  12.   Another unit containing definitions for different musical tones *)
  13.  
  14. { Designer's Notes:
  15.   1. This unit was written was with the goal of making tedious crt
  16.      routines much more bearable by modularizing the entire process.
  17.      Another goal is to make the routines very fast by directly
  18.      affecting memory.  Consequently, much of the error checking has
  19.      been left out.  The user is responsible for error checking his
  20.      own code.  In many cases this proves to give the user more
  21.      control, and there is little or no overhead if the code was
  22.      written with some care.  For example, many times a rectangle
  23.      is defined by (x1,y1) & (x2,y2) which represent the upper-left
  24.      and lower-right corners, respectively.  If x1>x2 or y1>y2 the
  25.      call is often ignored.
  26.   2. When setting foreground colors, you can set the blink constant
  27.      by adding 128 (pre-defined as 'blink') to the foreground color.
  28.   3. As yet, this unit is only designed to handle screens with
  29.      80 columns.  Including checking for 40 columns would slow
  30.      down the procedures which are intended to be very fast.
  31.      A program using 40 columns could easily borrow the ideas
  32.      used in this unit.  I have confirmed that they do work for
  33.      43/50 rows.  Many don't work for 40 columns.
  34.   4. All window-like procedures are in absolute coordinates.  Once
  35.      again, it up to the user to maintain relative coordinates
  36.      somehow (it is not very difficult) because that would slow down
  37.      the routines for other uses.
  38.   5. My apologies for my somewhat abnormal style of indentation, but
  39.      at least it is consistent (unlike some other code I have seen).
  40.      You may also notice that I avoid white spaces and capitalization
  41.      with a passion.  It seems very silly to worry about how many
  42.      spaces I have put between variables, so I don't put any unless
  43.      absolutely necessary.  I do try to keep my commenting neat, when
  44.      convenient. }
  45.  
  46. interface
  47.  
  48. uses crt,dos,keydef;
  49.  
  50. const
  51.   blackbg=$00;
  52.   bluebg=$10;
  53.   greenbg=$20;
  54.   cyanbg=$30;
  55.   redbg=$40;
  56.   magentabg=$50;
  57.   brownbg=$60;
  58.   lightgraybg=$70;
  59.  { Setting the text color and background color at the same time can
  60.    be very tedious.  You have to say TextColor(X) and TextBackGround(Y),
  61.    which is much too much typing.  You can also be clever and set
  62.    TextAttr:=Y*16+X, which is a pain.  This can be made simpler by
  63.    setting TextAttr:=YBG+X, which sets the background color at the
  64.    same with a minimum of typing.  It also lets you avoid trying to
  65.    set background colors to 8-15, something that I have tried often.
  66.    More importantly, it makes it clearer to see what is happening.
  67.  
  68.    For example, instead of
  69.  
  70.    TextColor(White); TextBackGround(Cyan) or TextAttr:=Cyan*16+White,
  71.  
  72.    much simpler would be
  73.  
  74.    TextAttr:=CyanBG+White.
  75.  
  76.     If you wish to set only the background or foreground color (but
  77.     not both), you can still use TextColor and TextBackGround. }
  78.  
  79.   { Text fonts, 25 or 43/50 rows }
  80.   ega43font=1;
  81.   normalfont=2;
  82.  
  83.  { border constants }
  84.   noborder=0;
  85.   singleborder=1;
  86.   doubleborder=2;
  87.   dtopsside=3;
  88.   stopdside=4;
  89.  
  90.  { textline constants }
  91.   thinhoriz=0;
  92.   thinvert=1;
  93.   thickhoriz=2;
  94.   thickvert=3;
  95.  
  96. type
  97.   screenpt=^screen;
  98.   screen=array[0..3999] of word;
  99.   { This is a maximum size for a screen - 80 columns * 50 rows = 4000.
  100.     The maximum space required would then be 8000 bytes. }
  101.   block=record
  102.     rows,cols: word;
  103.     sp: screenpt
  104.     end;
  105.   getoneofstring=string[120];
  106.   writexystring=string[80];
  107.  
  108. var
  109.   badkeybeep: boolean;     { beep when a bad is pressed? }
  110.   badkeyhz: word;          { sound to emit for bad key }
  111.   badkeydur: word;         { duration of bad key beep }
  112.   goodkeybeep: boolean;    { beep when a good key is pressed }
  113.   goodkeyhz: word;         { sound to emit for good key }
  114.   goodkeydur: word;        { duration of good key beep }
  115.   cursorinitial, cursoroff, cursorunderline,
  116.     cursorhalfblock, cursorblock: word;    { cursor settings }
  117.   preserveattr: boolean;
  118.   { If preserveattr=true, putch will preserve the attribute settings
  119.     for a location on the screen.  If preserveattr=false (default),
  120.     it will change the color attributes to the setting held in
  121.     textattr. }
  122.   crtrows,                 { Number of rows }
  123.   crtcols,                 { Number of columns }
  124.   videomode:byte;          { Video-mode }
  125.  
  126. procedure beep(hz,dur: word);
  127. function getch(x,y: byte):char;
  128. function getattr(x,y: byte):byte;
  129. procedure putch(x,y: byte; c: char);
  130. procedure putattr(x,y:byte; attr:byte);
  131. function shadowattr(attr:byte):byte;
  132. procedure writexy(x,y: byte; s: writexystring);
  133. procedure rightjust(x,y: byte; s: writexystring);
  134. procedure centerjust(x,y:byte; s:writexystring);
  135. procedure textbox(x1,y1,x2,y2: word; border:byte);
  136. procedure textline(startat,endat,c:word; attr:byte);
  137. procedure colorblock(x1,y1,x2,y2: word; c:byte);
  138. procedure fillblock(x1,y1,x2,y2:word; ch:char);
  139. procedure shadowblock(x1,y1,x2,y2:word);
  140. procedure attrblock(x1,y1,x2,y2:word; attr:byte);
  141. procedure scrollblockup(x1,y1,x2,y2,wakeattr:byte);
  142. procedure scrollblockdown(x1,y1,x2,y2,wakeattr:byte);
  143. procedure explodeblock(x1,y1,x2,y2:byte);
  144. function readallkeys:char;
  145. function yesorno:char;
  146. function getoneof(s:getoneofstring):char;
  147. function getcursor:word;
  148. procedure setcursor(curs:word);
  149. procedure savewindow(x1,y1,x2,y2: word; var w: block);
  150. procedure killwindow(var w:block);
  151. procedure recallwindow(x1,y1:word; var w: block);
  152. function getfont:byte;
  153. procedure setfont(font:byte);
  154. function getvideomode:byte;
  155. procedure setvideomode(mode:byte);
  156. procedure xcrtinit;
  157.  
  158. implementation
  159.  
  160. const
  161.   borders:array[0..4] of string[6]=('      ',
  162.                                     '┌─┐│┘└',
  163.                                     '╔═╗║╝╚',
  164.                                     '╒═╕│╛╘',
  165.                                     '╓─╖║╜╙');
  166.  
  167. var
  168.   regs: registers;
  169.   videoseg: word;        { Video segment address }
  170.  
  171. procedure beep(hz,dur: word);
  172. begin
  173.   sound(hz);
  174.   delay(dur);
  175.   nosound
  176. end;
  177.  
  178. function getch(x,y: byte):char;
  179. { returns character at absolute position (x,y) through memory
  180.   The error checking has been removed to speed up function }
  181. begin
  182.   getch:=char(mem[videoseg:(160*y+2*x-162)]);    { 2*80*(y-1)+2*(x-1) }
  183. end;
  184.  
  185. function getattr(x,y: byte):byte;
  186. { returns color attribute at absolute position (x,y) through memory
  187.   The error checking has been removed to speed up function }
  188. begin
  189.   getattr:=mem[videoseg:(160*y+2*x-161)];    { 2*80*(y-1)+2*(x-1)+1 }
  190. end;
  191.  
  192. procedure putch(x,y: byte; c: char);
  193. { QUICKLY writes c to absolute position (x,y) through memory
  194.   This is at least 10 times faster than a gotoxy(x,y), write(c)
  195.   Another bonus is that the cursor doesn't move.
  196.   The error checking has been removed  }
  197. begin
  198.   if not preserveattr then
  199.     memw[videoseg:(160*y+2*x-162)]:=textattr shl 8+ord(c)
  200.   else mem[videoseg:(160*y+2*x-162)]:=ord(c)
  201. end;
  202.  
  203. procedure putattr(x,y,attr: byte);
  204. { Directly change the color attributes of char at absolute screen (x,y) }
  205. begin
  206.   mem[videoseg:(160*y+2*x-161)]:=attr
  207. end;
  208.  
  209. function shadowattr(attr:byte):byte;
  210. { Returns an appropriate shadow attribute.  First it masks out the
  211.   upper four bits (background of shadow is always black) as well as
  212.   the 3rd bit (a shadow should be a dark color).  Unfortunately,
  213.   if the text color is black, you can't see it, so there is a
  214.   special case for that (sets it to lightgray). }
  215. var
  216.   temp: byte;
  217. begin
  218.   temp:=attr and $07;
  219.   if temp=black then shadowattr:=lightgray
  220.   else shadowattr:=temp
  221. end;
  222.  
  223. procedure writexy(x,y: byte; s: writexystring);
  224. { Writes string s at absolute (x,y) - left justified }
  225. var
  226.   i: byte;
  227. begin
  228.   for i:=1 to length(s) do putch(x+i-1,y,s[i])
  229. end;
  230.  
  231. procedure rightjust(x,y: byte; s: writexystring);
  232. { Right justifies string s at absolute (x,y) }
  233. begin
  234.   writexy(x-length(s)+1,y,s)
  235. end;
  236.  
  237. procedure centerjust(x,y:byte; s:writexystring);
  238. { Centers string s about x at y }
  239. begin
  240.   writexy(x-length(s) div 2,y,s)
  241. end;
  242.  
  243. procedure textbox(x1,y1,x2,y2: word; border:byte);
  244. { draws a text box defined by the two points }
  245. var
  246.   i: integer;
  247.   ch: char;
  248.   s: string[6];
  249. begin
  250.   if not border in [1..4] then exit;
  251.   s:=borders[border];
  252.   { handle special cases first, x1=x2 or y1=y2 }
  253.   if x1=x2 then   { straight line down }
  254.     for i:=y1 to y2 do putch(x1,i,s[4])
  255.   else if y1=y2 then  { straight line across }
  256.     for i:=x1 to x2 do putch(i,y1,s[2])
  257.   else if (x1<x2) and (y1<y2) then begin
  258.     { draw corners }
  259.     putch(x1,y1,s[1]);
  260.     putch(x1,y2,s[6]);
  261.     putch(x2,y2,s[5]);
  262.     putch(x2,y1,s[3]);
  263.     { draw lines }
  264.     for i:=y1+1 to y2-1 do putch(x1,i,s[4]);
  265.     for i:=y1+1 to y2-1 do putch(x2,i,s[4]);
  266.     for i:=x1+1 to x2-1 do begin
  267.       putch(i,y1,s[2]);
  268.       putch(i,y2,s[2]);
  269.       end
  270.     end
  271. end;
  272.  
  273. procedure textline(startat,endat,c:word; attr:byte);
  274. { The first two parameters are the starting and ending values
  275.   of the range of the line, vertical or horizontal.  The third
  276.   is the constant value.  i.e. horiz => (x1,x2,y), vert => (y1,y2,x) }
  277. var
  278.   i: integer;
  279. begin
  280.   if attr mod 2=0 then begin
  281.     gotoxy(startat,c);
  282.     if attr div 2=0 then for i:=startat to endat do putch(i,c,'─')
  283.     else for i:=startat to endat do putch(i,c,'═')
  284.     end
  285.   else
  286.     if attr div 2=0 then for i:=startat to endat do putch(c,i,'│')
  287.     else for i:=startat to endat do putch(c,i,'║')
  288. end;
  289.  
  290. procedure colorblock(x1,y1,x2,y2:word; c:byte);
  291. { Fills block with █ in the specified color - preserves color settings.
  292.   Can conflict with shadowing - ShadowBlock changes the background
  293.   color of the shadowed region to black and foreground colors to
  294.   the approriate shadowed color.  Therefore, if you shadow a region
  295.   containing █'s, it will not make them black.  Make sense?  If you
  296.   intend to use shadowing, you are better off making regions with
  297.   background colors and using FillBlock.  In addition, if text is to
  298.   be put in the area, the text must have an appropriate background
  299.   color.  ColorBlock should basically only be used for cosmetic
  300.   purposes (such as filling in the sides of the screen), as it
  301.   conflicts with so many other routines. }
  302. var
  303.   i,j:byte;
  304.   sc: byte;
  305. begin
  306.   sc:=textattr;
  307.   textcolor(c);
  308.   for i:=x1 to x2 do
  309.     for j:=y1 to y2 do putch(i,j,'█');
  310.   textattr:=sc
  311. end;
  312.  
  313. procedure fillblock(x1,y1,x2,y2:word; ch:char);
  314. { Fills a block with the specified character using the current
  315.   color settings.  If you want to empty a region, set the colors
  316.   by setting (as an example) TextAttr=CyanBG+White (cyan background
  317.   with a white foreground) and the fill the block with ' '. }
  318. var
  319.   i,j:byte;
  320. begin
  321.   for i:=x1 to x2 do
  322.     for j:=y1 to y2 do putch(i,j,ch)
  323. end;
  324.  
  325. procedure shadowblock(x1,y1,x2,y2:word);
  326. { Shadows a block using the appropriate shadowing
  327.   for each character's color attribute }
  328. var
  329.   i,j:byte;
  330. begin
  331.   for i:=x1 to x2 do
  332.     for j:=y1 to y2 do putattr(i,j,shadowattr(getattr(i,j)))
  333. end;
  334.  
  335. procedure attrblock(x1,y1,x2,y2:word; attr:byte);
  336. { Changes the foreground and background colors within the
  337.   specified rectangle.  This is different from shadowblock,
  338.   which uses the appropriate shadowing for a color attribute. }
  339. var
  340.   i,j: byte;
  341. begin
  342.   for i:=x1 to x2 do
  343.     for j:=y1 to y2 do putattr(i,j,attr);
  344. end;
  345.  
  346. procedure scrollblockup(x1,y1,x2,y2,wakeattr:byte);
  347. { Scrolls a block up and leaves the wakeattr color in the empty row }
  348. begin
  349.   fillchar(regs,sizeof(regs),0);
  350.   regs.ah:=$06;
  351.   regs.al:=$01;
  352.   regs.bh:=wakeattr;
  353.   regs.ch:=y1-1;
  354.   regs.cl:=x1-1;
  355.   regs.dh:=y2-1;
  356.   regs.dl:=x2-1;
  357.   intr($10,regs);
  358. end;
  359.  
  360. procedure scrollblockdown(x1,y1,x2,y2,wakeattr:byte);
  361. { Scrolls a block down and leaves the wakeattr color in the empty row }
  362. begin
  363.   fillchar(regs,sizeof(regs),0);
  364.   regs.ah:=$07;
  365.   regs.al:=$01;
  366.   regs.bh:=wakeattr;
  367.   regs.ch:=y1-1;
  368.   regs.cl:=x1-1;
  369.   regs.dh:=y2-1;
  370.   regs.dl:=x2-1;
  371.   intr($10,regs);
  372. end;
  373.  
  374. procedure explodeblock(x1,y1,x2,y2:byte);
  375. { explodes a block }
  376. var
  377.   i,r1,r2,c1,c2: byte;
  378.   mr,mc,dr,dc: real;
  379. begin
  380.   dr:=(x2-x1+1)/11;
  381.   dc:=(y2-y1+1)/11;
  382.   mr:=(x1+x2+1)/2;
  383.   mc:=(y1+y2+1)/2;
  384.   for i:=1 to 5 do begin
  385.     r1:=trunc(mr-i*dr);
  386.     r2:=trunc(mr+i*dr);
  387.     c1:=trunc(mc-i*dc);
  388.     c2:=trunc(mc+i*dc);
  389.     fillblock(r1,c1,r2,c2,' ');
  390.     end;
  391.   fillblock(x1,y1,x2,y2,' ');
  392. end;
  393.  
  394. function readallkeys:char;
  395. { This function correctly reads in a keypress and returns the
  396.   correct value for "other" keys.  See the KEYDEF unit for what
  397.   each special key returns.  Note: the function doesn't return
  398.   an actual character for special keys (F1-F10,etc.) - it is only
  399.   a character to represent the special key that was pressed. }
  400. var
  401.   ch: char;
  402. begin
  403.   ch:=readkey;
  404.   if ch=#0 then readallkeys:=transformedkey(readkey)
  405.   else readallkeys:=ch
  406. end;
  407.  
  408. procedure badkeysound;
  409. begin
  410.   beep(badkeyhz,badkeydur);
  411. end;
  412.  
  413. procedure goodkeysound;
  414. begin
  415.   beep(goodkeyhz,goodkeydur)
  416. end;
  417.  
  418. function yesorno:char;
  419. { waits for the user to press 'y','Y','n','N' }
  420. var
  421.   ch: char;
  422. begin
  423.   repeat
  424.     ch:=upcase(readallkeys);
  425.     if not (ch in ['Y','N']) and badkeybeep then badkeysound
  426.   until ch in ['Y','N'];
  427.   yesorno:=ch;
  428.   if goodkeybeep then goodkeysound
  429. end;
  430.  
  431. function getoneof(s:getoneofstring):char;
  432. { waits for the user to input a character contained in cs }
  433. var
  434.   ch: char;
  435. begin
  436.   repeat
  437.     ch:=readallkeys;
  438.     if badkeybeep and (pos(ch,s)<=0) then badkeysound
  439.   until pos(ch,s)>0;
  440.   getoneof:=ch;
  441.   if goodkeybeep then goodkeysound;
  442. end;
  443.  
  444. function getcursor:word;
  445. { returns cursor size }
  446. begin
  447.   getcursor:=(mem[$0040:$0060] shl 4)+mem[$0040:$0061];
  448. end;
  449.  
  450. procedure setcursor(curs:word);
  451. { sets cursor size }
  452. begin
  453.   fillchar(regs,sizeof(regs),0);
  454.   regs.ah:=$01;
  455.   regs.ch:=curs mod 16;
  456.   regs.cl:=curs div 16;
  457.   intr($10,regs);
  458. end;
  459.  
  460. procedure savewindow(x1,y1,x2,y2: word; var w: block);
  461. { This procedure saves a screen block.  It is not intended to
  462.   open up a window, but can be used to store what is underneath
  463.   a window.  (absolute coordinates) }
  464. var
  465.   i,j: word;
  466.   size: word;
  467. begin
  468.   with w do begin
  469.     rows:=0;
  470.     cols:=0;
  471.     if (x2<x1) and (y2<y1) then exit;    { invalid window }
  472.     rows:=x2-x1+1;
  473.     cols:=y2-y1+1;
  474.     size:=rows*cols*2;    { bytes required to store screen }
  475.     getmem(sp,size);      { allocate sufficient space }
  476.     for i:=0 to rows-1 do
  477.       for j:=0 to cols-1 do
  478.         sp^[j*rows+i]:=memw[videoseg:(160*(j+y1)+2*(i+x1)-162)];
  479.     end
  480. end;
  481.  
  482. procedure killwindow(var w:block);
  483. { Free space taken up by screen block (absolute coordinates) }
  484. begin
  485.   with w do freemem(sp,rows*cols*2)
  486. end;
  487.  
  488. procedure recallwindow(x1,y1:word; var w:block);
  489. { redraw window at (x1,y1) (absolute coordinates) }
  490. var
  491.   i,j: word;
  492. begin
  493.   with w do
  494.     for i:=0 to rows-1 do
  495.       for j:=0 to cols-1 do
  496.         memw[videoseg:(160*(j+y1)+2*(i+x1)-162)]:=sp^[j*rows+i]
  497. end;
  498.  
  499. function getfont:byte;
  500. { gets the number of rows on the screen }
  501. begin
  502.   fillchar(regs,sizeof(regs),0);
  503.   regs.ah:=$11;
  504.   regs.al:=$30;
  505.   regs.bh:=$02;
  506.   intr($10,regs);
  507.   getfont:=regs.dl+1;
  508. end;
  509.  
  510. procedure setfont(font:byte);
  511. { sets the number of rows on the screen:25 or 43/50 }
  512. begin
  513.   if font=normalfont then begin
  514.     fillchar(regs,sizeof(regs),0);
  515.     regs.ah:=$00;
  516.     regs.al:=videomode;
  517.     intr($10,regs);
  518.     crtrows:=25;
  519.     end
  520.   else begin
  521.     fillchar(regs,sizeof(regs),0);
  522.     regs.ah:=$11;
  523.     regs.al:=$12;
  524.     regs.bh:=$00;
  525.     intr($10,regs);
  526.     crtrows:=getfont;
  527.     end;
  528. end;
  529.  
  530. function getvideomode:byte;
  531. { Returns the Video mode }
  532. begin
  533.   fillchar(regs,sizeof(regs),0);
  534.   regs.ah:=$0F;
  535.   intr($10,regs);
  536.   getvideomode:=regs.al;
  537. end;
  538.  
  539. procedure setvideomode(mode:byte);
  540. { sets the video mode }
  541. begin
  542.   if not mode in [$02,$03,$07] then exit;
  543.   fillchar(regs,sizeof(regs),0);
  544.   regs.ah:=$00;
  545.   regs.al:=mode;
  546.   intr($10,regs);
  547. end;
  548.  
  549. procedure xcrtinit;
  550. { initializes some variables }
  551. begin
  552.  { initialize bad key settings }
  553.   badkeybeep:=false;
  554.   badkeyhz:=250;
  555.   badkeydur:=50;
  556.  { initialize good key settings }
  557.   goodkeybeep:=false;
  558.   goodkeyhz:=150;
  559.   goodkeydur:=10;
  560.   preserveattr:=false;
  561.  { initialize videomode }
  562.   videomode:=getvideomode;
  563.   if not videomode in [$02,$03,$07] then halt;   { invalid video mode }
  564.  { initialize cursor stuff }
  565.   cursorinitial:=getcursor;
  566.   crtcols:=80;
  567.   case videomode of
  568.     $02,$03:begin
  569.       cursorunderline:=118;  { 6-7 }
  570.       cursorhalfblock:=116;  { 4-7 }
  571.       cursorblock:=113;      { 1-7 }
  572.       cursoroff:=1;          { 0-1 }
  573.       videoseg:=$B800;
  574.       end;
  575.     $07:begin
  576.       cursorunderline:=203;  { 11-12 }
  577.       cursorhalfblock:=198;   { 6-12 }
  578.       cursorblock:=193;       { 1-12 }
  579.       cursoroff:=1;           { 0- 1 }
  580.       videoseg:=$B000;
  581.       end;
  582.     end;
  583.   crtrows:=getfont;
  584. end;
  585.  
  586. begin
  587.   xcrtinit;
  588. end.
  589.